home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / xlisp-1.6 / pt.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  4.9 KB  |  189 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         pt.lsp
  5. ; RCS:          $Header: $
  6. ; Description:  This is a sample XLISP program. It implements a simple form of
  7. ;        programmable turtle for VT100 compatible terminals.
  8. ;        To run it:
  9. ;            A>xlisp pt
  10. ;        This should cause the screen to be cleared and two turtles to appear.
  11. ;        They should each execute their simple programs and then the prompt
  12. ;        should return.  Look at the code to see how all of this works.
  13. ; Author:       ???
  14. ; Created:      Sat Oct  5 21:00:10 1991
  15. ; Modified:     Sat Oct  5 21:01:12 1991 (Niels Mayer) mayer@hplnpm
  16. ; Language:     Lisp
  17. ; Package:      N/A
  18. ; Status:       X11r5 contrib tape release
  19. ;
  20. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  21. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  22. ;
  23. ; Permission to use, copy, modify, distribute, and sell this software and its
  24. ; documentation for any purpose is hereby granted without fee, provided that
  25. ; the above copyright notice appear in all copies and that both that
  26. ; copyright notice and this permission notice appear in supporting
  27. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  28. ; used in advertising or publicity pertaining to distribution of the software
  29. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  30. ; makes no representations about the suitability of this software for any
  31. ; purpose.  It is provided "as is" without express or implied warranty.
  32. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33.  
  34. ; Get some more memory
  35. (expand 1)
  36.  
  37. ; Clear the screen
  38. (defun clear ()
  39.     (princ "\e[H\e[J"))
  40.  
  41. ; Move the cursor
  42. (defun setpos (x y)
  43.     (princ "\e[") (princ y) (princ ";") (princ x) (princ "H"))
  44.  
  45. ; Kill the remainder of the line
  46. (defun kill ()
  47.     (princ "\e[K"))
  48.  
  49. ; Move the cursor to the currently set bottom position and clear the line
  50. ;  under it
  51. (defun bottom ()
  52.     (setpos bx (+ by 1))
  53.     (kill)
  54.     (setpos bx by)
  55.     (kill))
  56.  
  57. ; Clear the screen and go to the bottom
  58. (defun cb ()
  59.     (clear)
  60.     (bottom))
  61.  
  62.  
  63. ; ::::::::::::
  64. ; :: Turtle ::
  65. ; ::::::::::::
  66.  
  67. ; Define "Turtle" class
  68. (setq Turtle (Class :new '(xpos ypos char)))
  69.  
  70. ; Answer ":isnew" by initing a position and char and displaying.
  71. (Turtle :answer :isnew '() '(
  72.     (setq xpos (setq newx (+ newx 1)))
  73.     (setq ypos 12)
  74.     (setq char "*")
  75.     (self :display)
  76.     self))
  77.  
  78. ; Message ":display" prints its char at its current position
  79. (Turtle :answer :display '() '(
  80.     (setpos xpos ypos)
  81.     (princ char)
  82.     (bottom)
  83.     self))
  84.  
  85. ; Message ":char" sets char to its arg and displays it
  86. (Turtle :answer :char '(c) '(
  87.     (setq char c)
  88.     (self :display)))
  89.  
  90. ; Message ":goto" goes to a new place after clearing old one
  91. (Turtle :answer :goto '(x y) '(
  92.     (setpos xpos ypos) (princ " ")
  93.     (setq xpos x)
  94.     (setq ypos y)
  95.     (self :display)))
  96.  
  97. ; Message ":up" moves up if not at top
  98. (Turtle :answer :up '() '(
  99.     (if (> ypos 0)
  100.     (self :goto xpos (- ypos 1))
  101.     (bottom))))
  102.  
  103. ; Message ":down" moves down if not at bottom
  104. (Turtle :answer :down '() '(
  105.     (if (< ypos by)
  106.     (self :goto xpos (+ ypos 1))
  107.     (bottom))))
  108.  
  109. ; Message ":right" moves right if not at right
  110. (Turtle :answer :right '() '(
  111.     (if (< xpos 80)
  112.     (self :goto (+ xpos 1) ypos)
  113.     (bottom))))
  114.  
  115. ; Message ":left" moves left if not at left
  116. (Turtle :answer :left '() '(
  117.     (if (> xpos 0)
  118.     (self :goto (- xpos 1) ypos)
  119.     (bottom))))
  120.  
  121.  
  122. ; :::::::::::::
  123. ; :: PTurtle ::
  124. ; :::::::::::::
  125.  
  126. ; Define "DPurtle" programable turtle class
  127. (setq PTurtle (Class :new '(prog pc) '() Turtle))
  128.  
  129. ; Message ":program" stores a program
  130. (PTurtle :answer :program '(p) '(
  131.     (setq prog p)
  132.     (setq pc prog)
  133.     self))
  134.  
  135. ; Message ":step" executes a single program step
  136. (PTurtle :answer :step '() '(
  137.     (if (null pc)
  138.     (setq pc prog))
  139.     (if pc
  140.     (progn (self (car pc))
  141.            (setq pc (cdr pc))))
  142.     self))
  143.  
  144. ; Message ":step#" steps each turtle program n times
  145. (PTurtle :answer :step# '(n) '(
  146.     (dotimes (x n) (self :step))
  147.     self))
  148.  
  149.  
  150. ; ::::::::::::::
  151. ; :: PTurtles ::
  152. ; ::::::::::::::
  153.  
  154. ; Define "PTurtles" class
  155. (setq PTurtles (Class :new '(turtles)))
  156.  
  157. ; Message ":make" makes a programable turtle and adds it to the collection
  158. (PTurtles :answer :make '(x y &aux newturtle) '(
  159.     (setq newturtle (PTurtle :new))
  160.     (newturtle :goto x y)
  161.     (setq turtles (cons newturtle turtles))
  162.     newturtle))
  163.  
  164. ; Message ":step" steps each turtle program once
  165. (PTurtles :answer :step '() '(
  166.     (mapcar '(lambda (turtle) (turtle :step)) turtles)
  167.     self))
  168.  
  169. ; Message ":step#" steps each turtle program n times
  170. (PTurtles :answer :step# '(n) '(
  171.     (dotimes (x n) (self :step))
  172.     self))
  173.  
  174.  
  175. ; Initialize things and start up
  176. (setq bx 0)
  177. (setq by 20)
  178. (setq newx 0)
  179.  
  180. ; Create some programmable turtles
  181. (cb)
  182. (setq turtles (PTurtles :new))
  183. (setq t1 (turtles :make 40 10))
  184. (setq t2 (turtles :make 41 10))
  185. (t1 :program '(:left :right :up :down))
  186. (t2 :program '(:right :left :down :up))
  187.  
  188.  
  189.